home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / slib / object.scm < prev    next >
Encoding:
Text File  |  1994-08-09  |  3.0 KB  |  98 lines
  1. ;;; "object.scm" Macroless Object System
  2. ;;;From: whumeniu@datap.ca (Wade Humeniuk)
  3.  
  4. ;;;Date:  February 15, 1994
  5.  
  6. ;; Object Construction:
  7. ;;       0           1          2             3              4
  8. ;; #(object-tag get-method make-method! unmake-method! get-all-methods)
  9.  
  10. (define object:tag "object")
  11.  
  12. ;;; This might be better done using COMLIST:DELETE-IF.
  13. (define (object:removeq obj alist)
  14.   (if (null? alist)
  15.       alist
  16.       (if (eq? (caar alist) obj)
  17.       (cdr alist)
  18.       (cons (car alist) (object:removeq obj (cdr alist))))))
  19.  
  20. (define (get-all-methods obj)
  21.   (if (object? obj)
  22.       ((vector-ref obj 4))
  23.       (slib:error "Cannot get methods on non-object: " obj)))
  24.  
  25. (define (object? obj)
  26.   (and (vector? obj)
  27.        (eq? object:tag (vector-ref obj 0))))
  28.  
  29. (define (make-method! obj generic-method method)
  30.   (if (object? obj)
  31.       (if (procedure? method)
  32.       (begin
  33.         ((vector-ref obj 2) generic-method method)
  34.         method)
  35.       (slib:error "Method must be a procedure: " method))
  36.       (slib:error "Cannot make method on non-object: " obj)))
  37.   
  38. (define (get-method obj generic-method)
  39.   (if (object? obj)
  40.       ((vector-ref obj 1) generic-method)
  41.       (slib:error "Cannot get method on non-object: " obj)))
  42.   
  43. (define (unmake-method! obj generic-method)
  44.   (if (object? obj)
  45.       ((vector-ref obj 3) generic-method)
  46.       (slib:error "Cannot unmake method on non-object: " obj)))
  47.   
  48. (define (make-predicate! obj generic-predicate)
  49.   (if (object? obj)
  50.       ((vector-ref obj 2) generic-predicate (lambda (self) #t))
  51.       (slib:error "Cannot make predicate on non-object: " obj)))
  52.  
  53. (define (make-generic-method . exception-procedure)
  54.   (define generic-method
  55.     (lambda (obj . operands)
  56.       (if (object? obj)
  57.       (let ((object-method ((vector-ref obj 1) generic-method)))
  58.         (if object-method
  59.         (apply object-method (cons obj operands))
  60.         (slib:error "Method not supported: " obj)))
  61.       (apply exception-procedure (cons obj operands)))))
  62.   
  63.   (if (not (null? exception-procedure))
  64.       (if (procedure? (car exception-procedure))
  65.       (set! exception-procedure (car exception-procedure))
  66.       (slib:error "Exception Handler Not Procedure:"))
  67.       (set! exception-procedure
  68.         (lambda (obj . params) 
  69.           (slib:error "Operation not supported: " obj))))
  70.   generic-method)
  71.   
  72. (define (make-generic-predicate)
  73.   (define generic-predicate 
  74.     (lambda (obj)
  75.       (if (object? obj)
  76.       (if ((vector-ref obj 1) generic-predicate)
  77.           #t 
  78.           #f)
  79.       #f)))
  80.   generic-predicate)
  81.   
  82. (define (make-object . ancestors)
  83.   (define method-list 
  84.     (apply append (map (lambda (obj) (get-all-methods obj)) ancestors)))
  85.   (define (make-method! generic-method method)
  86.     (set! method-list (cons (cons generic-method method) method-list))
  87.     method)
  88.   (define (unmake-method! generic-method) 
  89.     (set! method-list (object:removeq generic-method method-list))
  90.     #t)
  91.   (define (all-methods) method-list)
  92.   (define (get-method generic-method)
  93.     (let ((method-def (assq generic-method method-list)))
  94.       (if method-def (cdr method-def) #f)))
  95.   (vector object:tag get-method make-method! unmake-method! all-methods))
  96.  
  97.  
  98.